home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d12
/
ptv1n2.arc
/
VGAMIXER.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-06-14
|
8KB
|
297 lines
PROGRAM VgaColorMixer;
{ Michael A. Covington 1990 }
USES Crt,Dos;
CONST Quality: ARRAY[1..5] OF String[12] =
('Redness','Greenness','Blueness','Saturation','Intensity');
CONST
C: INTEGER = 1; { Color being edited }
Q: INTEGER = 1; { Quality being edited }
R: ARRAY[1..3] OF REAL = (63.05, 0, 0); { Red component }
G: ARRAY[1..3] OF REAL = ( 0, 63.05, 0); { Green component }
B: ARRAY[1..3] OF REAL = ( 0, 0, 63.05); { Blue component }
PROCEDURE SetRgbPalette(ColorNum,Red,Green,Blue:INTEGER);
{ Like the SetRgbPalette procedure provided
in GRAPH.TPU, but does not require .BGI files.
Copy and use in your own programs. }
VAR
R: Registers;
BEGIN
R.ax := $1010;
R.bx := ColorNum;
R.dh := Red;
R.ch := Green;
R.cl := Blue;
Intr($10,R)
END;
PROCEDURE HideCursor;
{ For VGA and most others. Undone by textmode(co80). }
VAR
R: Registers;
BEGIN
R.cx := $2000; { Start cursor on scan line $20, end on $00 }
R.ah := 1; { i.e., end it before it starts }
Intr($10,R)
END;
PROCEDURE Block(Left,Upper,Right,Lower,Color: INTEGER);
VAR
Row, Col: INTEGER;
BEGIN
TextColor(Color);
FOR Row := Upper TO Lower DO
FOR Col := Left TO Right DO
BEGIN
GoToXY(Col,Row); write(#219)
END;
TextColor(White);
END;
PROCEDURE Box(Left,Upper,Right,Lower,Color: INTEGER);
BEGIN
Block(Left,Upper,Left,Lower,Color);
Block(Right,Upper,Right,Lower,Color);
Block(Left,Upper,Right,Upper,Color);
Block(Left,Lower,Right,Lower,Color)
END;
PROCEDURE WriteCentered(Msg:String;Row,Color:INTEGER);
BEGIN
GoToXY(40-(length(Msg) div 2),Row);
write(Msg)
END;
PROCEDURE WriteInverse(Msg:String);
BEGIN
TextBackground(White);
TextColor(Black);
write(Msg);
TextColor(White);
TextBackground(Black)
END;
PROCEDURE UpdateColors;
{ Updates just those parts of the screen that change }
{ when the user alters a color quality }
VAR
j, red, green, blue: INTEGER;
BEGIN
SetRgbPalette(4,round(R[C]),round(G[C]),round(B[C]));
{ Color 4 will always be the color currently being edited }
FOR j:=1 TO 3 DO
BEGIN
SetRgbPalette(j,round(R[j]),round(G[j]),round(B[j]));
{ Label the colors }
TextColor(White);
GoToXY(20*j-3,9);
IF j=C THEN
WriteInverse('Color '+chr(ord('0')+j))
ELSE
write('Color '+chr(ord('0')+j));
GoToXY(20*j-7,7);
IF j=C THEN
TextColor(White)
ELSE
TextColor(LightGray);
Write( 'R=',round(R[j]):2,
' G=',round(G[j]):2,
' B=',round(B[j]):2);
END;
{ Update the menu of qualities }
TextBackground(Black); TextColor(White);
GoToXY(11,19);
FOR j:=1 TO 5 DO
BEGIN
IF j=Q THEN
WriteInverse(Quality[j])
ELSE
Write(Quality[j]);
Write(' ')
END
END;
PROCEDURE UpdateScreen;
VAR
j,k: INTEGER;
BEGIN
TextMode(Co80); { Clears screen and resets colors }
HideCursor;
UpdateColors;
Box(1,1,80,21,DarkGray);
WriteCentered('V G A C o l o r M i x e r',3,White);
WriteCentered('TAB chooses color to edit',22,White);
WriteCentered(
#$1B + ' ' + #$1A + ' choose a quality to alter',
23,White);
WriteCentered(
#$18 + ' increases and ' + #$19 + ' decreases that quality',
24,White);
WriteCentered('Alt-X ends program',25,White);
{ Color swatches }
Block(11,5,29,6,1);
Block(31,5,49,6,2);
Block(51,5,69,6,3);
{ Large patch of the color currently being edited }
Block(11,11,69,15,4);
{ Text samples }
GoToXY(10,17);
FOR j:=1 to 3 DO
FOR k:=1 TO 3 DO
IF j<>k THEN
BEGIN
TextBackground(Black); Write(' ');
TextBackground(j);
TextColor(k);
Write(' ',k,' on ',j,' ')
END;
TextBackground(Black);
END;
FUNCTION Min(X,Y,Z:REAL):REAL;
BEGIN
IF X<Y THEN
{ Minimum is not Y }
IF X<Z THEN Min:=X ELSE Min:=Z
ELSE
{ Minimum is not X }
IF Y<Z THEN Min:=Y ELSE Min:=Z
END;
FUNCTION Max(X,Y,Z:REAL):REAL;
BEGIN
IF X>Y THEN
{ Maximum is not Y }
IF X>Z THEN Max:=X ELSE Max:=Z
ELSE
{ Maximum is not X }
IF Y>Z THEN Max:=Y ELSE Max:=Z
END;
{ Main }
VAR
Keys: string;
Top, Factor: real;
BEGIN
UpdateScreen;
Keys := '';
WHILE TRUE DO
BEGIN
IF Keys = '' then Keys := ReadKey;
CASE Keys[1] OF
#09 : { Tab }
BEGIN
C := C MOD 3 + 1;
UpdateColors
END;
#27 : { First byte of any non-ASCII key }
{ do nothing };
#72 : { Up arrow }
BEGIN
CASE Q OF
1: IF R[C]<62.5 THEN R[C] := R[C]+1;
2: IF G[C]<62.5 THEN G[C] := G[C]+1;
3: IF B[C]<62.5 THEN B[C] := B[C]+1;
4: { Up saturation }
BEGIN
Top := Max(R[C],G[C],B[C]);
IF Min(R[C],G[C],B[C]) > 0.5 THEN
BEGIN
Factor := (Top-Min(R[C],G[C],B[C]));
IF Factor > 0 THEN
BEGIN
Factor := 1/Factor;
R[C] := R[C] + Factor*(R[C] - Top);
G[C] := G[C] + Factor*(G[C] - Top);
B[C] := B[C] + Factor*(B[C] - Top)
END
END
END;
5: { Up intensity }
IF Max(R[C],G[C],B[C])<62.5 THEN
BEGIN
R[C] := R[C]*1.01;
G[C] := G[C]*1.01;
B[C] := B[C]*1.01
END
END;
UpdateColors
END;
#73 : { PgUp = five Up Arrows }
Keys := Keys[1]+#72+#72+#72+#72+#72+copy(Keys,2,255);
#80 : { Down arrow }
BEGIN
CASE Q OF
1: IF R[C]>=0.5 THEN R[C] := R[C]-1;
2: IF G[C]>=0.5 THEN G[C] := G[C]-1;
3: IF B[C]>=0.5 THEN B[C] := B[C]-1;
4: { Down saturation }
BEGIN
Top := Max(R[C],G[C],B[C]);
IF (Top-Min(R[C],G[C],B[C])) > 0.5 THEN
BEGIN
Factor := 1/Abs(Top-Min(R[C],G[C],B[C]));
R[C] := R[C] - Factor*(R[C] - Top);
G[C] := G[C] - Factor*(G[C] - Top);
B[C] := B[C] - Factor*(B[C] - Top)
END
END;
5: { Down intensity }
BEGIN
R[C]:=R[C]*0.99;
G[C]:=G[C]*0.99;
B[C]:=B[C]*0.99
END
END;
UpdateColors
END;
#81 : { PgDn = five Down Arrows }
Keys := Keys[1]+#80+#80+#80+#80+#80+copy(Keys,2,255);
#75 : { Left arrow }
BEGIN
IF Q > 1 THEN Dec(Q);
UpdateColors
END;
#77 : { Right arrow }
BEGIN
IF Q < 5 THEN Inc(Q);
UpdateColors
END;
#45 : { Alt-X }
BEGIN
TextMode(Co80); { Reset colors }
Halt
END
END {Case};
Delete(Keys,1,1); { Eat the keystroke that was just acted on }
END
END.